unit ExtraClasses;

interface

uses
  SysUtils, Classes, contnrs;

type
  TCircularQueue = class
  private
    FSize  : integer;
    FCount : integer;
    FData  : PPointerList;
    FFirst : integer;
    FLast  : integer;
  public
    constructor Create( qsize: integer );
    destructor Destroy; override;
    function IsFull: boolean;
    function IsEmpty: boolean;
    function Put( data: pointer ): boolean;
    function Get: pointer;
    function Peek: pointer;
    property Size: integer read FSize;
    property Count: integer read FCount;
  end;

  TStringListEx = class(TStringList)
  private
    FDupInsLast : boolean;
  public
    function AddObject(const S: string; AObject: TObject): Integer; override;
    property DuplicatesInsertLast: boolean read FDupInsLast write FDupInsLast;
  end;

  TStringObjectList = class(TStringListEx)
  private
    FOwnsObjects : boolean;
  public
    procedure Clear; override;
    constructor Create( AOwnsObjects: boolean= true );
    destructor Destroy; override;
    procedure Delete(Index: Integer); override;
    function Remove(AObject: TObject): integer;
    property OwnsObjects: boolean read FOwnsObjects;
  end;

  TEventsList = class; {forward declaration}
  TEventsListId = longint;
  TEventsListAction = (eaNext, eaAgain, eaRemove);
  TEventsListProc = procedure( List: TEventsList; Id: TEventsListId; Data: pointer;
                               var Action: TEventsListAction ) of object;
  TEventsList = class
  private
    FEvents    : TList;
    FNextEvent : integer;
    function ExecuteEvent( Id: TEventsListId; var Action: TEventsListAction ): boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function IsEmpty: boolean;
    function Count: integer;
    function Add( Proc: TEventsListProc; Data: pointer ): TEventsListId;
    function Remove( Id: TEventsListId ): boolean;
    function EventExists( Id: TEventsListId ): boolean;
    procedure ExecuteFirst;
    procedure ExecuteNext;
    procedure Execute;
  end;

  TProcedureOfObject = procedure of object;
  TProcOfObjWithParams = procedure( Params: array of const ) of object;
  TNotifyEventWithParam = procedure( Sender: TObject; Param: pointer ) of object;
  TForEachMethod = procedure( Sender: TObject; AMethod: TProcedureOfObject; Param: pointer ) of object;
  TMethodList = class
  private
    FList : TList;
    FIdx  : integer;
    FOnChange : TNotifyEvent;
    function GetCount: integer;
    function GetItems(idx: integer): TProcedureOfObject;
    procedure SetItems(idx: integer; const Value: TProcedureOfObject);
    procedure Change;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function Add( AMethod: TProcedureOfObject ): integer; overload;
    function Add( AMethod: TProcOfObjWithParams ): integer; overload;
    function Add( AMethod: TNotifyEvent ): integer; overload;
    function Add( AMethod: TNotifyEventWithParam ): integer; overload;
    procedure Delete( idx: integer );
    function IndexOf( AMethod: TProcedureOfObject ): integer;
    function Remove( AMethod: TProcedureOfObject ): integer; overload;
    function Remove( AMethod: TProcOfObjWithParams ): integer; overload;
    function Remove( AMethod: TNotifyEvent ): integer; overload;
    function Remove( AMethod: TNotifyEventWithParam ): integer; overload;
    procedure Execute; overload;
    procedure ExecuteNotifyEvent( Sender: TObject ); overload;
    procedure ExecuteNotifyEvent( Sender: TObject; Param: pointer ); overload;
    procedure Execute( Params: array of const ); overload;
    procedure ForEach( AForEachMethod: TForEachMethod; Param: pointer= nil );
    property Items[ idx: integer ]: TProcedureOfObject read GetItems write SetItems; default;
    property Count: integer read GetCount;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TCommands = class; // forward declaration

  TExecuteCommandEvent = procedure( Sender: TCommands; Params: string; var result: string ) of object;
  TCommand = class
    Name       : string;
    OnExecute  : TExecuteCommandEvent;
    constructor Create( const Nam: string; Even: TExecuteCommandEvent );
  end;

  TCommands = class
  private
    FCommands : TObjectList;
    FCommandBreak : boolean;
    FResults : TStrings;
    FMultiCommandsLineSep : char;
    function GetCommand(idx: integer): TCommand;
    function GetCount: integer;
  public
    constructor Create;
    destructor Destroy; override;
    function IndexOf( Nom: string ): integer;
    function Find( Nom: string ): TCommand;
    function Add( const Nam: string; Even: TExecuteCommandEvent ): TCommand;
    procedure Del( const Nam: string );
    procedure Execute( coms: TStrings ); overload;
    procedure Execute( const comandos: string ); overload;
    procedure Break;
    property Count: integer read GetCount;
    property Command[ idx: integer ]: TCommand read GetCommand;
    property CommandBreak: boolean read FCommandBreak;
    property Results: TStrings read FResults;
    property MultiCommandsLineSep: char read FMultiCommandsLineSep write FMultiCommandsLineSep;
  end;

function FreeObjectFromList( obj: TObject; list: TList ): boolean;
procedure FreeMemFromList( list: TList );
procedure FreeObjectsFromList( list: TList );
procedure FreeObjectsFromStrings( list: TStrings );
function IsMethodEqual( const m1, m2 ): boolean;

implementation

uses
  RTLConsts, StrTools;

resourcestring
  rsCommsErr1 = 'Error: comando "%s" desconocido.';
  rsCommsErr2 = 'Error procesando comando: %s';

{ TCircularQueue }

constructor TCircularQueue.Create( qsize: integer );
begin
  inherited Create;
  FSize := qsize;
  FLast := -1;
  GetMem(FData,FSize*SizeOf(pointer));
end;

destructor TCircularQueue.Destroy;
begin
  FreeMem(FData,FSize*SizeOf(pointer));
  inherited Destroy;
end;

function TCircularQueue.IsFull: boolean;
begin
  result := FCount=FSize;
end;

function TCircularQueue.IsEmpty: boolean;
begin
  result := FCount=0;
end;

function TCircularQueue.Put( data: pointer ): boolean;
begin
  if IsFull then result := false
  else
  begin
    inc(FLast);
    if FLast=FSize then FLast := 0;
    FData^[FLast] := data;
    inc(FCount);
    result := true;
  end;
end;

function TCircularQueue.Get: pointer;
begin
  if IsEmpty then result := nil
  else
  begin
    result := FData^[FFirst];
    inc(FFirst);
    if FFirst=FSize then FFirst := 0;
    dec(FCount);
  end;
end;

function TCircularQueue.Peek: pointer;
begin
  if IsEmpty then result := nil
             else result := FData^[FFirst];
end;

{ TStringListEx }

function TStringListEx.AddObject(const S: string; AObject: TObject): Integer;
  procedure SkipEquals;
  begin
    while (Result<Count) and (CompareStrings(Strings[Result],S)=0) do
      inc(Result);
  end;
begin
  if not Sorted then
    Result := Count
  else
    if Find(S, Result) then
      case Duplicates of
        dupIgnore: Exit;
        dupError:  Error(@SDuplicateString, 0);
        dupAccept: if FDupInsLast then SkipEquals;
      end;
  InsertItem(Result, S, AObject);
end;

{ TStringObjectList }

procedure TStringObjectList.Clear;
var
  i : integer;
begin
  if OwnsObjects then
    for i := 0 to Count-1 do
      TObject(Objects[i]).Free;
  inherited;
end;

constructor TStringObjectList.Create(AOwnsObjects: boolean);
begin
  inherited Create;
  FOwnsObjects := AOwnsObjects;
end;

procedure TStringObjectList.Delete(Index: Integer);
begin
  if OwnsObjects then Objects[Index].Free;
  inherited;
end;

destructor TStringObjectList.Destroy;
begin
  Clear;
  inherited;
end;

function TStringObjectList.Remove(AObject: TObject): integer;
begin
  result := IndexOfObject(AObject);
  if result<0 then exit;
  Delete(result);
end;

{ TEventsList }

type
  TEventData = record
    Proc : TEventsListProc;
    Data : pointer;
  end;
  PEventData = ^TEventData;

constructor TEventsList.Create;
begin
  FEvents := TList.Create;
  inherited Create;
end;

destructor TEventsList.Destroy;
begin
  Clear;
  FEvents.Free;
  inherited Destroy;
end;

procedure TEventsList.Clear;
var
  i : integer;
begin
  for i := 0 to FEvents.Count-1 do
    Dispose(PEventData(FEvents[i]));
  FEvents.Clear;
  FNextEvent := 0;
end;

function TEventsList.IsEmpty: boolean;
begin
  result := FEvents.Count=0;
end;

function TEventsList.Count: integer;
begin
  result := FEvents.Count;
end;

function TEventsList.Add( Proc: TEventsListProc; Data: pointer ): TEventsListId;
var
  d : PEventData;
begin
  New(d);
  d^.Proc := Proc;
  d^.Data := Data;
  FEvents.Add(d);
  result := TEventsListId(d);
end;

function TEventsList.Remove( Id: TEventsListId ): boolean;
var
  r : integer;
begin
  result := false;
  if Id=0 then exit;
  r := FEvents.Remove(PEventData(Id));
  if r<0 then exit;
  Dispose(PEventData(Id));
  if r<FNextEvent then dec(FNextEvent)
  else if FNextEvent>FEvents.Count-1 then FNextEvent := 0;
  result := true;
end;

function TEventsList.EventExists( Id: TEventsListId ): boolean;
begin
  result := FEvents.IndexOf(PEventData(Id))>=0;
end;

function TEventsList.ExecuteEvent( Id: TEventsListId; var Action: TEventsListAction ): boolean;
begin
  result := false;
  if Id=0 then exit;
  with PEventData(Id)^ do
    if Assigned(Proc) then
      try
        Proc(Self,Id,Data,Action);
        result := true;
      except
        Remove(Id);
      end;
end;

procedure TEventsList.ExecuteFirst;
begin
  if IsEmpty then exit;
  FNextEvent := 0;
  ExecuteNext;
end;

procedure TEventsList.ExecuteNext;
var
  id     : TEventsListId;
  Action : TEventsListAction;
begin
  if FNextEvent>=FEvents.Count then exit;
  Action := eaNext;
  id := TEventsListId(FEvents[FNextEvent]);
  ExecuteEvent(id,Action);
  case Action of
    eaAgain: ;
    eaNext:
      if FNextEvent<FEvents.Count-1 then inc(FNextEvent)
                                    else FNextEvent := 0;
    eaRemove:
      Remove(id);
  end;
end;

procedure TEventsList.Execute;
begin
  if IsEmpty then exit;
  FNextEvent := 0;
  ExecuteNext;
  while FNextEvent<>0 do ExecuteNext;
end;

{ TMethodList }

function TMethodList.Add(AMethod: TProcedureOfObject): integer;
begin
  result := FList.Add(TMethod(AMethod).Data) div 2;
  FList.Add(TMethod(AMethod).Code);
  Change;
end;

function TMethodList.Add( AMethod: TProcOfObjWithParams ): integer;
var
  m : TProcedureOfObject;
begin
  m := TProcedureOfObject(AMethod);
  result := Add(m);
end;

function TMethodList.Add( AMethod: TNotifyEvent ): integer;
var
  m : TProcedureOfObject;
begin
  m := TProcedureOfObject(AMethod);
  result := Add(m);
end;

function TMethodList.Add( AMethod: TNotifyEventWithParam ): integer;
var
  m : TProcedureOfObject;
begin
  m := TProcedureOfObject(AMethod);
  result := Add(m);
end;

procedure TMethodList.Clear;
begin
  FList.Clear;
  Change;
end;

constructor TMethodList.Create;
begin
  inherited;
  FList := TList.Create;
  FIdx  := -1;
end;

procedure TMethodList.Delete(idx: integer);
begin
  FList.Delete(idx*2);
  FList.Delete(idx*2);
  if idx<=FIdx then dec(FIdx);
  Change;
end;

destructor TMethodList.Destroy;
begin
  //Clear;
  FList.Free;
  inherited;
end;

function TMethodList.GetCount: integer;
begin
  result := FList.Count div 2;
end;

function TMethodList.GetItems(idx: integer): TProcedureOfObject;
begin
  with TMethod(result) do
  begin
    Data := FList[idx*2];
    Code := FList[idx*2+1];
  end;
end;

function TMethodList.IndexOf(AMethod: TProcedureOfObject): integer;
begin
  for result := 0 to Count-1 do
    with TMethod(Items[result]) do
      if (Code=TMethod(AMethod).Code) and
         (Data=TMethod(AMethod).Data) then exit;
  result := -1;
end;

function TMethodList.Remove(AMethod: TProcedureOfObject): integer;
begin
  result := IndexOf(AMethod);
  if result<0 then exit;
  Delete(result);
end;

function TMethodList.Remove( AMethod: TProcOfObjWithParams ): integer;
var
  m : TProcedureOfObject;
begin
  m := TProcedureOfObject(AMethod);
  result := Remove(m);
end;

function TMethodList.Remove(AMethod: TNotifyEvent): integer;
var
  m : TProcedureOfObject;
begin
  m := TProcedureOfObject(AMethod);
  result := Remove(m);
end;

function TMethodList.Remove(AMethod: TNotifyEventWithParam): integer;
var
  m : TProcedureOfObject;
begin
  m := TProcedureOfObject(AMethod);
  result := Remove(m);
end;

procedure TMethodList.SetItems(idx: integer; const Value: TProcedureOfObject);
begin
  with TMethod(Value) do
  begin
    FList[idx*2]   := Data;
    FList[idx*2+1] := Code;
  end;
  Change;
end;

procedure TMethodList.Execute;
var
  p : TProcedureOfObject;
begin
  if FIdx>=0 then exit;
  FIdx := 0;
  while FIdx<=Count-1 do
  begin
    p := Items[FIdx]; p;
    inc(FIdx);
  end;
  FIdx := -1;
end;

procedure TMethodList.ExecuteNotifyEvent( Sender: TObject );
var
  e : TNotifyEvent;
begin
  if FIdx>=0 then exit;
  FIdx := 0;
  while FIdx<=Count-1 do
  begin
    e := TNotifyEvent(Items[FIdx]);
    e(Sender);
    inc(FIdx);
  end;
  FIdx := -1;
end;

procedure TMethodList.ExecuteNotifyEvent(Sender: TObject; Param: pointer);
var
  e : TNotifyEventWithParam;
begin
  if FIdx>=0 then exit;
  FIdx := 0;
  while FIdx<=Count-1 do
  begin
    e := TNotifyEventWithParam(Items[FIdx]);
    e(Sender,Param);
    inc(FIdx);
  end;
  FIdx := -1;
end;

procedure TMethodList.Execute( Params: array of const );
var
  e : TProcOfObjWithParams;
begin
  if FIdx>=0 then exit;
  FIdx := 0;
  while FIdx<=Count-1 do
  begin
    e := TProcOfObjWithParams(Items[FIdx]);
    e(Params);
    inc(FIdx);
  end;
  FIdx := -1;
end;

procedure TMethodList.ForEach(AForEachMethod: TForEachMethod; Param: pointer);
//var
//  p : TProcedureOfObject;  {ph Variable innecesaria}
begin
  if FIdx>=0 then exit;
  FIdx := 0;
  while FIdx<=Count-1 do
  begin
    AForEachMethod(Self,Items[FIdx],Param);
    inc(FIdx);
  end;
  FIdx := -1;
end;

procedure TMethodList.Change;
begin
  if assigned(FOnChange) then FOnChange(Self);
end;

{ TCommand }

constructor TCommand.Create(const Nam: string; Even: TExecuteCommandEvent);
begin
  inherited Create;
  Name := Nam;
  OnExecute := Even;
end;

{ TCommands }

constructor TCommands.Create;
begin
  inherited;
  FMultiCommandsLineSep := ';';
  FCommands := TObjectList.Create;
  FResults := TStringList.Create;
end;

destructor TCommands.Destroy;
begin
  FResults.Free;
  FCommands.Free;
  inherited;
end;

function TCommands.Add(const Nam: string; Even: TExecuteCommandEvent): TCommand;
begin
  result := TCommand.Create(Nam,Even);
  FCommands.Add(result);
end;

procedure TCommands.Break;
begin
  FCommandBreak := true;
end;

procedure TCommands.Del(const Nam: string);
var
  i : integer;
begin
  i := IndexOf(Nam);
  if i<0 then exit;
  FCommands.Delete(i);
end;

procedure TCommands.Execute(const comandos: string );
var
  l : TStringList;
begin
  l := TStringList.Create;
  SepStrToStrings(comandos,FMultiCommandsLineSep,l,[poSkipQuoted,poSkipParentheses,poSkipBrackets,poSkipBraces]);
  Execute(l);
  l.Free;
end;

procedure TCommands.Execute(coms: TStrings);
var
  l,o,r : string;
  c     : TCommand;
  i     : integer;
begin
  FCommandBreak := false;
  FResults.Clear;
  for i := 0 to coms.Count-1 do
  begin
    l := UpperCase(coms[i]);
    o := GetParam('(',l);
    l := Trim(GetParam(')',l,[poSkipQuoted,poSkipParentheses,poSkipBrackets,poSkipBraces]));
    try
      c := Find(o);
      if c<>nil then
      begin
        r := '';
        c.OnExecute(Self,l,r);
        if r>'' then FResults.Add(r);
      end
      else
        FResults.Add(format(rsCommsErr1,[o]));
      if FCommandBreak then break;
    except
      on e: Exception do
        FResults.Add(format(rsCommsErr2,[e.Message]));
    end;
  end;
end;

function TCommands.Find(Nom: string): TCommand;
var
  i : integer;
begin
  i := IndexOf(Nom);
  if i>=0 then result := Command[i]
          else result := nil;
end;

function TCommands.GetCommand(idx: integer): TCommand;
begin
  result := TCommand(FCommands[idx]);
end;

function TCommands.GetCount: integer;
begin
  result := FCommands.Count;
end;

function TCommands.IndexOf(Nom: string): integer;
begin
  Nom := UpperCase(Nom);
  for result := Count-1 downto 0 do
    if UpperCase(Command[result].Name)=Nom then exit;
  result := -1;
end;

{ Rutinas }

function IsMethodEqual( const m1, m2 ): boolean;
begin
  result := (TMethod(m1).Code=TMethod(m2).Code) and (TMethod(m1).Data=TMethod(m2).Data);
end;

function FreeObjectFromList( obj: TObject; list: TList ): boolean;
var
  i : integer;
begin
  i := list.IndexOf(obj);
  result := i>=0;
  if not result then exit;
  obj.Free;
  list.Delete(i);
end;

procedure FreeMemFromList( list: TList );
var
  i : integer;
begin
  if list=nil then exit;
  for i := 0 to list.Count-1 do
    FreeMem(list[i]);
  list.Clear;
end;

procedure FreeObjectsFromList( list: TList );
var
  i : integer;
begin
  if list=nil then exit;
  for i := 0 to list.Count-1 do
    TObject(list[i]).Free;
  list.Clear;
end;

procedure FreeObjectsFromStrings( list: TStrings );
var
  i : integer;
begin
  if list=nil then exit;
  for i := 0 to list.Count-1 do
    TObject(list.Objects[i]).Free;
  list.Clear;
end;

end.
